Shareware Grab Bag/Shareware Grab Bag.iso/013/td3.arc/TD.LIB

Text File | 1986-03-18 | 5.8 KB | 214 lines

{ Turbodraw library  ( PC version ) }

{ 3/18/86 - Added sound to signal keying errors }

type
    stype = string[20];

const
    ctlh = ^H;   { Backspace }
    ctlm = ^M;   {  Return   }


function getnum(p,q:integer):stype;    { 12/19/84 }

{ Called by: GETINT(P) and GETREAL(p,q)                      }

{ Getnum allows entry of a number of Scale P and Precision Q }
{ The operator is not allowed to enter a number with greater }
{ precision and/or scale.  Character delete using the back-  }
{ space key can be used.                                     }

var
    i      : integer;
    number : stype;       { Input buffer }
    digit  : char;
    frac   : integer;
    dp     : boolean;

begin
    I:=1;
    Dp:=false;
    Frac:=0;
    Digit:=' ';
    Number:=' ';

    while Digit <> ctlm do
        begin          { don't exit until a CR is entered }
        read(kbd,digit);
        write(digit);
        If Digit=ctlh Then { backspace }
            If I > 1 Then
                begin
                I:=I-1;
                If Dp=TRUE Then Frac:=Frac-1;
                If Copy(Number,I,1)='.' Then
                    begin     { special handling for decimal point }
                    Dp:=FALSE;
                    Frac:=0   { just to make sure its at zero    }
                End;
                number:=copy(number,1,i-1)+' '+copy(number,i+1,20);
                write(' ' + ctlh)     { Delete character on screen }
            End
            Else { If I>1 }
            begin
                sound(600);
                delay(10);
                nosound;
                write(' ');  { put cursor back }
            end;
            If Digit='-' Then
                If I = 1 Then
                    begin
                    number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
                    I:=I+1;
                End
                Else
                    Digit:=' ';
            if digit in ['0'..'9'] then
                begin;
                If Dp=TRUE Then { we are past decimal point }
                    begin
                    if (I=P+2) or (Frac = q) Then
                    begin
                        sound(200);
                        delay(10);
                        nosound;
                        write(ctlh + ' ' + ctlh);  { At full prec. }
                    end
                    Else
                        begin
                        number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
                        Frac:=Frac+1;
                        I:=I+1;
                    End
                End
                Else    { If DP }
                If I=P-Q+1 Then   { allow only a '.' }
                begin
                    sound(200);
                    delay(10);
                    nosound;
                    write(ctlh + ' ' + ctlh);
                end
                Else
                    begin
                    number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
                    I:=I+1;
                End;

            End                   { If verify }
            Else
            If Digit='.' Then
                If Dp=FALSE Then { only one decimal per number }
                    begin
                    number:=copy(number,1,i-1)+'.'+copy(number,i+1,20);
                    I:=I+1;
                    Dp:=TRUE;
                End
                Else
                begin
                  sound(600);
                  delay(10);
                  nosound;
                  Digit:=' ';  { eliminate extra decimal point }
                end;
                if not (digit in ['-','0'..'9','.',ctlh,ctlm]) then
                begin
                    sound(600);
                    delay(10);
                    nosound;
                    write(ctlh + ' ' + ctlh);
                end;
            End;  { Do While }

           getnum:=number;
       end;

function getreal(len,scale : integer) : real;

{ GETREAL returns a number of max length LEN }
{ and max scale SCALE                        }

var
   i,j,temp,sign  : integer;
   result         : real;
   digit          : char;
   num            : stype;
   code           : integer;

begin
   num:=getnum(len,scale);
   i:=length(num);
   j:=1;
   sign:=1;
   while i > 0 do
       begin
       digit:=copy(num,i,1);
       i:=i-1;
       case digit of
           '0'..'9' : begin
                         val(digit,temp,code);
                         result:=result+(temp*j);
                         j:=j*10;
                      end;
           '-'      : sign:=-1;
           '.'      : begin
                         result:=result/j;
                         j:=1;
                      end;
        end;
    end;
    getreal:=result*sign;
end;

function getint(len : integer) : integer;

{ GETINT returns a number of max length LEN and }
{ a scale of zero ( integer )                   }

var
   result,code : integer;
   num         : stype;

begin
   val(getnum(len,0),result,code);
   getint:=result;
end;

{ HEX support functions and procedures }

function tohex(nibble : integer) : char;  { convert 1/2 byte to hex 0-F }
begin
    if nibble > 9 then
        tohex:=chr(nibble+55)
    else
        tohex:=chr(nibble+48);
end;

procedure prbyte(num : byte); { display a byte as a two digit hex number }
var
  num1      : integer;
  nibl,nib2 : integer;
  c         : char;

begin
    num1:=num;
    nibl:=trunc(num1/16);
    write(tohex(nibl));
    nib2:=num1-(nibl*16);
    write(tohex(nib2));
 end;

procedure prword(num : integer); { display integer as 4 digit hex number }
var
  bt1,bt2 : byte;

begin
    bt1:=(trunc(num/256));
    bt2:=(num-(bt1*256));
    prbyte(bt1);
    prbyte(bt2);
end;